home *** CD-ROM | disk | FTP | other *** search
/ SuperHack / SuperHack CD.bin / CODING / DELPHI / SEMAPH~1.ZIP / SEMAPH~1.PAS
Encoding:
Pascal/Delphi Source File  |  1996-09-27  |  3.5 KB  |  140 lines
  1. { Semaphor.pas                                                                }
  2. { Copyright 1996, TASC Inc.  All rights reserved.                             }
  3. {                                                                             }
  4. { Created by: Michael T. Nygard                                               }
  5. {                                                                             }
  6. { Version 1.0                                                                 }
  7.  
  8. unit semaphore;
  9.  
  10. (*
  11. **  This unit exports the class TSemaphore, an encapsulation of the Win32
  12. ** semaphore object API.  Security descriptors are not supported.
  13. **
  14. **  Use Create to construct a new semaphore, use the alternate constructor
  15. ** Open to access an existing semaphore.  After the semaphore is constructed,
  16. ** use Get and Put to do "downs" and "ups", respectively.
  17. **
  18. **
  19. ** Get - if timeout is 0, the semaphore will not block, but will return
  20. **                failure immediately if it cannot be acquired.  fAlertable will
  21. **                allow I/O completion routines and other asynchronous alerts to
  22. **                occur during the WaitForSingleObject.
  23. **
  24. ** Put - pass the release count (amount to increment the semaphore).  Returns
  25. **                the previous value.
  26. *)
  27.  
  28. interface
  29.  
  30. uses
  31.     SysUtils, Windows, Classes;
  32.  
  33. const
  34.     SEMAPHORE_ALL_ACCESS: ULONG            = $001F0003;
  35.  
  36. type
  37.     TSemaphore = class;
  38.  
  39.     ESemaphoreError = class(Exception)
  40.     end;
  41.  
  42.     TSemaphoreEvent = procedure(Sender: TSemaphore) of object;
  43.  
  44.     TSemaphore = class
  45.         private
  46.             FHandle: THandle;
  47.             FName: string;
  48.             FLastStatus: DWORD;
  49.  
  50.         protected
  51.             FOnBeforeGet: TSemaphoreEvent;
  52.             FOnAfterGet: TSemaphoreEvent;
  53.             FOnBeforePut: TSemaphoreEvent;
  54.             FOnAfterPut: TSemaphoreEvent;
  55.  
  56.             function GetLastErrorCode: DWORD; virtual;
  57.  
  58.         public
  59.             constructor Create(const name: string; const initial, max: Longint); virtual;
  60.             constructor Open(const name: string); virtual;
  61.  
  62.             destructor Destroy; virtual;
  63.  
  64.             function   Get(timeout: DWORD; bAlertable: boolean): boolean;
  65.             function   Put(count: integer): Longint;
  66.  
  67.             property Name: string read FName;
  68.             property Handle: THandle read FHandle;
  69.             property LastStatus: DWORD read FLastStatus;
  70.             property LastError: DWORD read GetLastErrorCode;
  71.     end;
  72.  
  73. implementation
  74.  
  75. constructor TSemaphore.Create(const name: string; const initial, max: Longint);
  76. var
  77.     hTmp: THandle;
  78. begin
  79.     hTmp := CreateSemaphore(nil, initial, max, PChar(name));
  80.  
  81.     if hTmp = 0 then
  82.         raise ESemaphoreError.Create('Cannot create semaphore.');
  83.  
  84.     FHandle := hTmp;
  85. end;
  86.  
  87. constructor TSemaphore.Open(const name: string);
  88. var
  89.     hTmp: THandle;
  90. begin
  91.     hTmp := OpenSemaphore(SEMAPHORE_ALL_ACCESS, true, PChar(name));
  92.  
  93.     if hTmp = 0 then
  94.         raise ESemaphoreError.Create('Cannot open semaphore.');
  95.  
  96.     FHandle := hTmp;
  97. end;
  98.  
  99. destructor TSemaphore.Destroy;
  100. begin
  101. end;
  102.  
  103. function   TSemaphore.Get(timeout: DWORD; bAlertable: boolean): boolean;
  104. begin
  105.     if Assigned(FOnBeforeGet) then FOnBeforeGet(Self);
  106.  
  107.     FLastStatus := WaitForSingleObjectEx(Handle, timeout, bAlertable);
  108.  
  109.     if (FLastStatus = WAIT_FAILED) or (FLastStatus = WAIT_ABANDONED) or (FLastStatus = WAIT_TIMEOUT) then
  110.         Result := false
  111.     else
  112.         Result := true;
  113.  
  114.     if Assigned(FOnAfterGet) then FOnAfterGet(Self);
  115. end;
  116.  
  117. function   TSemaphore.Put(count: integer): Longint;
  118. var
  119.     lastValue: Longint;
  120.     success: boolean;
  121. begin
  122.     if Assigned(FOnBeforePut) then FOnBeforePut(Self);
  123.  
  124.     success := ReleaseSemaphore(Handle, count, @lastValue);
  125.  
  126.     if success then
  127.         Result := lastValue
  128.     else
  129.         Result := -1;
  130.  
  131.     if Assigned(FOnAfterPut) then FOnAfterPut(Self);
  132. end;
  133.  
  134. function TSemaphore.GetLastErrorCode: DWORD;
  135. begin
  136.     Result := GetLastError;
  137. end;
  138.  
  139. end.
  140.